home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / srcuc.zip / SYNTAX.C < prev    next >
C/C++ Source or Header  |  1991-05-20  |  25KB  |  927 lines
  1. /* -*-C-*-
  2.  
  3. $Header: /scheme/microcode/RCS/syntax.c,v 1.21 1991/05/20 20:31:51 cph Exp $
  4.  
  5. Copyright (c) 1987-91 Massachusetts Institute of Technology
  6.  
  7. This material was developed by the Scheme project at the Massachusetts
  8. Institute of Technology, Department of Electrical Engineering and
  9. Computer Science.  Permission to copy this software, to redistribute
  10. it, and to use it for any purpose is granted, subject to the following
  11. restrictions and understandings.
  12.  
  13. 1. Any copy made of this software must include this copyright notice
  14. in full.
  15.  
  16. 2. Users of this software agree to make their best efforts (a) to
  17. return to the MIT Scheme project any improvements or extensions that
  18. they make, so that these may be included in future releases; and (b)
  19. to inform MIT of noteworthy uses of this software.
  20.  
  21. 3. All materials developed as a consequence of the use of this
  22. software shall duly acknowledge such use, in accordance with the usual
  23. standards of acknowledging credit in academic research.
  24.  
  25. 4. MIT has made no warrantee or representation that the operation of
  26. this software will be error-free, and MIT is under no obligation to
  27. provide any services, by way of maintenance, update, or otherwise.
  28.  
  29. 5. In conjunction with products arising from the use of this material,
  30. there shall be no use of the name of the Massachusetts Institute of
  31. Technology nor of any adaptation thereof in any advertising,
  32. promotional, or sales literature without prior written consent from
  33. MIT in each case. */
  34.  
  35. /* Primitives to support Edwin syntax tables, word and list parsing. */
  36.  
  37. /* NOTE: This program was created by translation from the syntax table
  38. code of GNU Emacs; it was translated from the original C to 68000
  39. assembly language (in 1986), and then translated back from 68000
  40. assembly language to C (in 1987).  Users should be aware that the GNU
  41. GENERAL PUBLIC LICENSE may apply to this code.  A copy of that license
  42. should have been included along with this file. */
  43.  
  44. #include "scheme.h"
  45. #include "prims.h"
  46. #include "edwin.h"
  47. #include "syntax.h"
  48.  
  49. /* Syntax Codes */
  50.  
  51. /* Convert a letter which signifies a syntax code
  52.    into the code it signifies. */
  53.  
  54. #define ILLEGAL ((char) syntaxcode_max)
  55.  
  56. char syntax_spec_code[0200] =
  57.   {
  58.     ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL,
  59.     ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL,
  60.     ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL,
  61.     ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL,
  62.  
  63.     ((char) syntaxcode_whitespace), ILLEGAL, ((char) syntaxcode_string),
  64.         ILLEGAL, ((char) syntaxcode_math), ILLEGAL, ILLEGAL,
  65.         ((char) syntaxcode_quote),
  66.     ((char) syntaxcode_open), ((char) syntaxcode_close), ILLEGAL, ILLEGAL,
  67.         ILLEGAL, ((char) syntaxcode_whitespace), ((char) syntaxcode_punct),
  68.         ((char) syntaxcode_charquote),
  69.     ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL,
  70.     ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ((char) syntaxcode_comment),
  71.         ILLEGAL, ((char) syntaxcode_endcomment), ILLEGAL,
  72.  
  73.     ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL,
  74.     ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL,
  75.     ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL,
  76.         ((char) syntaxcode_word),
  77.     ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ((char) syntaxcode_escape), ILLEGAL,
  78.         ILLEGAL, ((char) syntaxcode_symbol),
  79.  
  80.     ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL,
  81.     ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL,
  82.     ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL,
  83.         ((char) syntaxcode_word),
  84.     ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL, ILLEGAL
  85.   };
  86.  
  87. /* Indexed by syntax code, give the letter that describes it. */
  88.  
  89. unsigned char syntax_code_spec[13] =
  90.   {
  91.     ' ', '.', 'w', '_', '(', ')', '\'', '\"', '$', '\\', '/', '<', '>'
  92.   };
  93.  
  94. #define MERGE_PREFIX_BIT(result, bit)                    \
  95. {                                    \
  96.   if ((result & bit) != 0)                        \
  97.     error_bad_range_arg (1);                        \
  98.   result |= bit;                            \
  99. }
  100.  
  101. DEFINE_PRIMITIVE ("STRING->SYNTAX-ENTRY", Prim_string_to_syntax_entry, 1, 1, 0)
  102. {
  103.   long length, c, result;
  104.   unsigned char * scan;
  105.   PRIMITIVE_HEADER (1);
  106.  
  107.   CHECK_ARG (1, STRING_P);
  108.   length = (STRING_LENGTH (ARG_REF (1)));
  109.   scan = (STRING_LOC ((ARG_REF (1)), 0));
  110.  
  111.   if ((length--) > 0)
  112.     {
  113.       c = (*scan++);
  114.       if (c >= 0200) error_bad_range_arg (1);
  115.       result = (syntax_spec_code [c]);
  116.       if (result == ILLEGAL) error_bad_range_arg (1);
  117.     }
  118.   else
  119.     result = ((long) syntaxcode_whitespace);
  120.  
  121.   if ((length--) > 0)
  122.     {
  123.       c = (*scan++);
  124.       if (c != ' ') result |= (c << 8);
  125.     }
  126.  
  127.   while ((length--) > 0)
  128.     switch (*scan++)
  129.       {
  130.       case '1': MERGE_PREFIX_BIT (result, (1 << 16)); break;
  131.       case '2': MERGE_PREFIX_BIT (result, (1 << 17)); break;
  132.       case '3': MERGE_PREFIX_BIT (result, (1 << 18)); break;
  133.       case '4': MERGE_PREFIX_BIT (result, (1 << 19)); break;
  134.       case 'p': MERGE_PREFIX_BIT (result, (1 << 20)); break;
  135.       case ' ': break;
  136.       default: error_bad_range_arg (1);
  137.       }
  138.  
  139.   PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (result));
  140. }
  141.  
  142. DEFINE_PRIMITIVE ("CHAR->SYNTAX-CODE", Prim_char_to_syntax_code, 2, 2, 0)
  143. {
  144.   PRIMITIVE_HEADER (2);
  145.   CHECK_ARG (1, SYNTAX_TABLE_P);
  146.   PRIMITIVE_RETURN
  147.     (ASCII_TO_CHAR
  148.      (syntax_code_spec
  149.       [((int)
  150.     (SYNTAX_ENTRY_CODE
  151.      (SYNTAX_TABLE_REF ((ARG_REF (1)), (arg_ascii_char (2))))))]));
  152. }
  153.  
  154. /* Parser Initialization */
  155.  
  156. #define NORMAL_INITIALIZATION_COMMON(arity)                \
  157.   fast SCHEME_OBJECT syntax_table;                    \
  158.   fast SCHEME_OBJECT group;                        \
  159.   fast unsigned char * start;                        \
  160.   unsigned char * first_char, * end;                    \
  161.   long sentry;                                \
  162.   long gap_length;                            \
  163.   PRIMITIVE_HEADER (arity);                        \
  164.   CHECK_ARG (1, SYNTAX_TABLE_P);                    \
  165.   syntax_table = (ARG_REF (1));                        \
  166.   CHECK_ARG (2, GROUP_P);                        \
  167.   group = (ARG_REF (2));                        \
  168.   first_char = (STRING_LOC ((GROUP_TEXT (group)), 0));            \
  169.   start = (first_char + (arg_nonnegative_integer (3)));            \
  170.   end = (first_char + (arg_nonnegative_integer (4)));            \
  171.   gap_start = (first_char + (GROUP_GAP_START (group)));            \
  172.   gap_length = (GROUP_GAP_LENGTH (group));                \
  173.   gap_end = (first_char + (GROUP_GAP_END (group)))
  174.  
  175. #define NORMAL_INITIALIZATION_FORWARD(arity)                \
  176.   unsigned char * gap_start;                        \
  177.   fast unsigned char * gap_end;                        \
  178.   NORMAL_INITIALIZATION_COMMON (arity);                    \
  179.   if (start >= gap_start)                        \
  180.     start += gap_length;                        \
  181.   if (end >= gap_start)                            \
  182.     end += gap_length
  183.  
  184. #define NORMAL_INITIALIZATION_BACKWARD(arity)                \
  185.   fast unsigned char * gap_start;                    \
  186.   unsigned char * gap_end;                        \
  187.   Boolean quoted;                            \
  188.   NORMAL_INITIALIZATION_COMMON (arity);                    \
  189.   if (start > gap_start)                        \
  190.     start += gap_length;                        \
  191.   if (end > gap_start)                            \
  192.     end += gap_length
  193.  
  194. #define SCAN_LIST_INITIALIZATION(initialization)            \
  195.   long depth, min_depth;                        \
  196.   Boolean sexp_flag, ignore_comments, math_exit;            \
  197.   int c;                                \
  198.   initialization (7);                            \
  199.   depth = (arg_integer (5));                        \
  200.   min_depth = ((depth >= 0) ? 0 : depth);                \
  201.   sexp_flag = (BOOLEAN_ARG (6));                    \
  202.   ignore_comments = (BOOLEAN_ARG (7));                    \
  203.   math_exit = false
  204.  
  205. /* Parse Scanning */
  206.  
  207. #define PEEK_RIGHT(scan) (SYNTAX_TABLE_REF (syntax_table, (*scan)))
  208. #define PEEK_LEFT(scan) (SYNTAX_TABLE_REF (syntax_table, (scan[-1])))
  209.  
  210. #define MOVE_RIGHT(scan) do                        \
  211. {                                    \
  212.   if ((++scan) == gap_start)                        \
  213.     scan = gap_end;                            \
  214. } while (0)
  215.  
  216. #define MOVE_LEFT(scan) do                        \
  217. {                                    \
  218.   if ((--scan) == gap_end)                        \
  219.     scan = gap_start;                            \
  220. } while (0)
  221.  
  222. #define READ_RIGHT(scan, target) do                    \
  223. {                                    \
  224.   target = (SYNTAX_TABLE_REF (syntax_table, (*scan++)));        \
  225.   if (scan == gap_start)                        \
  226.     scan = gap_end;                            \
  227. } while (0)
  228.  
  229. #define READ_LEFT(scan, target) do                    \
  230. {                                    \
  231.   target = (SYNTAX_TABLE_REF (syntax_table, (*--scan)));        \
  232.   if (scan == gap_end)                            \
  233.     scan = gap_start;                            \
  234. } while (0)
  235.  
  236. #define RIGHT_END_P(scan) (scan >= end)
  237. #define LEFT_END_P(scan) (scan <= end)
  238.  
  239. #define LOSE_IF(expression) do                        \
  240. {                                    \
  241.   if (expression)                            \
  242.     PRIMITIVE_RETURN (SHARP_F);                        \
  243. } while (0)
  244.  
  245. #define LOSE_IF_RIGHT_END(scan) LOSE_IF (RIGHT_END_P (scan))
  246. #define LOSE_IF_LEFT_END(scan) LOSE_IF (LEFT_END_P (scan))
  247.  
  248. #define SCAN_TO_INDEX(scan)                        \
  249.   ((((scan) > gap_start) ? ((scan) - gap_length) : (scan)) - first_char)
  250.  
  251. #define WIN_IF(expression) do                        \
  252. {                                    \
  253.   if (expression)                            \
  254.     PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (SCAN_TO_INDEX (start)));    \
  255. } while (0)
  256.  
  257. #define WIN_IF_RIGHT_END(scan) WIN_IF (RIGHT_END_P (scan))
  258. #define WIN_IF_LEFT_END(scan) WIN_IF (LEFT_END_P (scan))
  259.  
  260. #define RIGHT_QUOTED_P_INTERNAL(scan, quoted) do            \
  261. {                                    \
  262.   long sentry;                                \
  263.                                     \
  264.   quoted = false;                            \
  265.   while (true)                                \
  266.     {                                    \
  267.       if (LEFT_END_P (scan))                        \
  268.     break;                                \
  269.       READ_LEFT (scan, sentry);                        \
  270.       if (! (SYNTAX_ENTRY_QUOTE (sentry)))                \
  271.     break;                                \
  272.       quoted = (! quoted);                        \
  273.     }                                    \
  274. } while (0)
  275.  
  276. #define RIGHT_QUOTED_P(scan_init, quoted) do                \
  277. {                                    \
  278.   unsigned char * scan = (scan_init);                    \
  279.   RIGHT_QUOTED_P_INTERNAL (scan, quoted);                \
  280. } while (0)
  281.  
  282. #define LEFT_QUOTED_P(scan_init, quoted) do                \
  283. {                                    \
  284.   unsigned char * scan = (scan_init);                    \
  285.   MOVE_LEFT (scan);                            \
  286.   RIGHT_QUOTED_P_INTERNAL (scan, quoted);                \
  287. } while (0)
  288.  
  289. /* Quote Parsers */
  290.  
  291. DEFINE_PRIMITIVE ("QUOTED-CHAR?", Prim_quoted_char_p, 4, 4, 0)
  292. {
  293.   NORMAL_INITIALIZATION_BACKWARD (4);
  294.  
  295.   RIGHT_QUOTED_P (start, quoted);
  296.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (quoted));
  297. }
  298.  
  299. /* This is used in conjunction with `scan-list-backward' to find the
  300.    beginning of an s-expression. */
  301.  
  302. DEFINE_PRIMITIVE ("SCAN-BACKWARD-PREFIX-CHARS", Prim_scan_backward_prefix_chars, 4, 4, 0)
  303. {
  304.   NORMAL_INITIALIZATION_BACKWARD (4);
  305.  
  306.   while (true)
  307.     {
  308.       WIN_IF_LEFT_END (start);
  309.       LEFT_QUOTED_P (start, quoted);
  310.       WIN_IF (quoted);
  311.       {
  312.     long sentry = (PEEK_LEFT (start));
  313.     WIN_IF (! (((SYNTAX_ENTRY_CODE (sentry)) == syntaxcode_quote)
  314.            || (SYNTAX_ENTRY_PREFIX (sentry))));
  315.       }
  316.       MOVE_LEFT (start);
  317.     }
  318. }
  319.  
  320. DEFINE_PRIMITIVE ("SCAN-FORWARD-PREFIX-CHARS", Prim_scan_forward_prefix_chars, 4, 4, 0)
  321. {
  322.   Boolean quoted;
  323.   NORMAL_INITIALIZATION_FORWARD (4);
  324.  
  325.   while (true)
  326.     {
  327.       WIN_IF_RIGHT_END (start);
  328.       RIGHT_QUOTED_P (start, quoted);
  329.       WIN_IF (quoted);
  330.       {
  331.     long sentry = (PEEK_RIGHT (start));
  332.     WIN_IF (! (((SYNTAX_ENTRY_CODE (sentry)) == syntaxcode_quote)
  333.            || (SYNTAX_ENTRY_PREFIX (sentry))));
  334.       }
  335.       MOVE_RIGHT (start);
  336.     }
  337. }
  338.  
  339. /* Word Parsers */
  340.  
  341. DEFINE_PRIMITIVE ("SCAN-FORWARD-TO-WORD", Prim_scan_forward_to_word, 4, 4, 0)
  342. {
  343.   NORMAL_INITIALIZATION_FORWARD (4);
  344.  
  345.   while (true)
  346.     {
  347.       LOSE_IF_RIGHT_END (start);
  348.       WIN_IF ((SYNTAX_ENTRY_CODE (PEEK_RIGHT (start))) == syntaxcode_word);
  349.       MOVE_RIGHT (start);
  350.     }
  351. }
  352.  
  353. DEFINE_PRIMITIVE ("SCAN-WORD-FORWARD", Prim_scan_word_forward, 4, 4, 0)
  354. {
  355.   NORMAL_INITIALIZATION_FORWARD (4);
  356.  
  357.   while (true)
  358.     {
  359.       LOSE_IF_RIGHT_END (start);
  360.       READ_RIGHT (start, sentry);
  361.       if ((SYNTAX_ENTRY_CODE (sentry)) == syntaxcode_word)
  362.     break;
  363.     }
  364.   while (true)
  365.     {
  366.       WIN_IF_RIGHT_END (start);
  367.       WIN_IF ((SYNTAX_ENTRY_CODE (PEEK_RIGHT (start))) != syntaxcode_word);
  368.       MOVE_RIGHT (start);
  369.     }
  370. }
  371.  
  372. DEFINE_PRIMITIVE ("SCAN-WORD-BACKWARD", Prim_scan_word_backward, 4, 4, 0)
  373. {
  374.   NORMAL_INITIALIZATION_BACKWARD (4);
  375.  
  376.   while (true)
  377.     {
  378.       LOSE_IF_LEFT_END (start);
  379.       READ_LEFT (start, sentry);
  380.       if ((SYNTAX_ENTRY_CODE (sentry)) == syntaxcode_word)
  381.     break;
  382.     }
  383.   while (true)
  384.     {
  385.       WIN_IF_LEFT_END (start);
  386.       WIN_IF ((SYNTAX_ENTRY_CODE (PEEK_LEFT (start))) != syntaxcode_word);
  387.       MOVE_LEFT (start);
  388.     }
  389. }
  390.  
  391. /* S-Expression Parsers */
  392.  
  393. DEFINE_PRIMITIVE ("SCAN-LIST-FORWARD", Prim_scan_list_forward, 7, 7, 0)
  394. {
  395.   SCAN_LIST_INITIALIZATION (NORMAL_INITIALIZATION_FORWARD);
  396.  
  397.   while (true)
  398.     {
  399.       LOSE_IF_RIGHT_END (start);
  400.       c = (*start);
  401.       READ_RIGHT(start, sentry);
  402.  
  403.       if ((! (RIGHT_END_P (start))) &&
  404.       (SYNTAX_ENTRY_COMSTART_FIRST (sentry)) &&
  405.       (SYNTAX_ENTRY_COMSTART_SECOND (PEEK_RIGHT (start))))
  406.     {
  407.       MOVE_RIGHT (start);
  408.       LOSE_IF_RIGHT_END (start);
  409.       while (true)
  410.         {
  411.           READ_RIGHT (start, sentry);
  412.           LOSE_IF_RIGHT_END (start);
  413.           if ((SYNTAX_ENTRY_COMEND_FIRST (sentry)) &&
  414.           (SYNTAX_ENTRY_COMEND_SECOND (PEEK_RIGHT (start))))
  415.         {
  416.           MOVE_RIGHT (start);
  417.           break;
  418.         }
  419.         }
  420.       continue;
  421.     }
  422.       if (SYNTAX_ENTRY_PREFIX (sentry))
  423.     continue;
  424.  
  425.       switch (SYNTAX_ENTRY_CODE (sentry))
  426.     {
  427.     case syntaxcode_escape:
  428.     case syntaxcode_charquote:
  429.       LOSE_IF_RIGHT_END (start);
  430.       MOVE_RIGHT (start);
  431.  
  432.     case syntaxcode_word:
  433.     case syntaxcode_symbol:
  434.       if ((depth != 0) || (! sexp_flag))
  435.         break;
  436.       while (true)
  437.         {
  438.           WIN_IF_RIGHT_END (start);
  439.           switch (SYNTAX_ENTRY_CODE (PEEK_RIGHT (start)))
  440.         {
  441.         case syntaxcode_escape:
  442.         case syntaxcode_charquote:
  443.           MOVE_RIGHT (start);
  444.           LOSE_IF_RIGHT_END (start);
  445.  
  446.         case syntaxcode_word:
  447.         case syntaxcode_symbol:
  448.           MOVE_RIGHT (start);
  449.           break;
  450.  
  451.         default:
  452.           WIN_IF (true);
  453.         }
  454.         }
  455.  
  456.     case syntaxcode_comment:
  457.       if (! ignore_comments)
  458.         break;
  459.       while (true)
  460.         {
  461.           LOSE_IF_RIGHT_END (start);
  462.           if ((SYNTAX_ENTRY_CODE (PEEK_RIGHT (start))) ==
  463.           syntaxcode_endcomment)
  464.         break;
  465.           MOVE_RIGHT (start);
  466.         }
  467.       break;
  468.  
  469.     case syntaxcode_math:
  470.       if (! sexp_flag)
  471.         break;
  472.       if ((! (RIGHT_END_P (start))) && (c == *start))
  473.         MOVE_RIGHT (start);
  474.       if (math_exit)
  475.         {
  476.           WIN_IF ((--depth) == 0);
  477.           LOSE_IF (depth < min_depth);
  478.           math_exit = false;
  479.         }
  480.       else
  481.         {
  482.           WIN_IF ((++depth) == 0);
  483.           math_exit = true;
  484.         }
  485.       break;
  486.  
  487.     case syntaxcode_open:
  488.       WIN_IF ((++depth) == 0);
  489.       break;
  490.  
  491.     case syntaxcode_close:
  492.       WIN_IF ((--depth) == 0);
  493.       LOSE_IF (depth < min_depth);
  494.       break;
  495.  
  496.     case syntaxcode_string:
  497.       while (true)
  498.         {
  499.           LOSE_IF_RIGHT_END (start);
  500.           if (c == *start)
  501.         break;
  502.           READ_RIGHT (start, sentry);
  503.           if (SYNTAX_ENTRY_QUOTE (sentry))
  504.         {
  505.           LOSE_IF_RIGHT_END (start);
  506.           MOVE_RIGHT (start);
  507.         }
  508.         }
  509.       MOVE_RIGHT (start);
  510.       WIN_IF ((depth == 0) && sexp_flag);
  511.       break;
  512.  
  513.     default:
  514.       break;
  515.     }
  516.     }
  517. }
  518.  
  519. DEFINE_PRIMITIVE ("SCAN-LIST-BACKWARD", Prim_scan_list_backward, 7, 7, 0)
  520. {
  521.   SCAN_LIST_INITIALIZATION (NORMAL_INITIALIZATION_BACKWARD);
  522.  
  523.   while (true)
  524.     {
  525.       LOSE_IF_LEFT_END (start);
  526.       LEFT_QUOTED_P (start, quoted);
  527.       if (quoted)
  528.     {
  529.       MOVE_LEFT (start);
  530.       /* existence of this character is guaranteed by LEFT_QUOTED_P. */
  531.       READ_LEFT (start, sentry);
  532.       goto word_entry;
  533.     }
  534.       c = (start[-1]);
  535.       READ_LEFT (start, sentry);
  536.       if ((! (LEFT_END_P (start))) &&
  537.       (SYNTAX_ENTRY_COMEND_SECOND (sentry)) &&
  538.       (SYNTAX_ENTRY_COMEND_FIRST (PEEK_LEFT (start))))
  539.     {
  540.       LEFT_QUOTED_P (start, quoted);
  541.       if (! quoted)
  542.         {
  543.           MOVE_LEFT (start);
  544.           LOSE_IF_LEFT_END (start);
  545.           while (true)
  546.         {
  547.           READ_LEFT (start, sentry);
  548.           LOSE_IF_LEFT_END (start);
  549.           if ((SYNTAX_ENTRY_COMSTART_SECOND (sentry)) &&
  550.               (SYNTAX_ENTRY_COMSTART_FIRST (PEEK_LEFT (start))))
  551.             {
  552.               MOVE_LEFT (start);
  553.               break;
  554.             }
  555.         }
  556.           continue;
  557.         }
  558.     }
  559.  
  560.       switch (SYNTAX_ENTRY_CODE (sentry))
  561.     {
  562.     case syntaxcode_word:
  563.     case syntaxcode_symbol:
  564.     word_entry:
  565.       if ((depth != 0) || (! sexp_flag))
  566.         break;
  567.       while (true)
  568.         {
  569.           WIN_IF_LEFT_END (start);
  570.           LEFT_QUOTED_P (start, quoted);
  571.           if (quoted)
  572.         MOVE_LEFT (start);
  573.           else
  574.         {
  575.           sentry = (PEEK_LEFT (start));
  576.           WIN_IF (((SYNTAX_ENTRY_CODE (sentry)) != syntaxcode_word) &&
  577.               ((SYNTAX_ENTRY_CODE (sentry)) != syntaxcode_symbol));
  578.         }
  579.           MOVE_LEFT (start);
  580.         }
  581.  
  582.     case syntaxcode_math:
  583.       if (! sexp_flag)
  584.         break;
  585.       if ((! (LEFT_END_P (start))) && (c == start[-1]))
  586.         MOVE_LEFT (start);
  587.       if (math_exit)
  588.         {
  589.           WIN_IF ((--depth) == 0);
  590.           LOSE_IF (depth < min_depth);
  591.           math_exit = false;
  592.         }
  593.       else
  594.         {
  595.           WIN_IF ((++depth) == 0);
  596.           math_exit = true;
  597.         }
  598.       break;
  599.  
  600.     case syntaxcode_close:
  601.       WIN_IF ((++depth) == 0);
  602.       break;
  603.  
  604.     case syntaxcode_open:
  605.       WIN_IF ((--depth) == 0);
  606.       LOSE_IF (depth < min_depth);
  607.       break;
  608.  
  609.     case syntaxcode_string:
  610.       while (true)
  611.         {
  612.           LOSE_IF_LEFT_END (start);
  613.           LEFT_QUOTED_P (start, quoted);
  614.           if ((! quoted) && (c == start[-1]))
  615.         break;
  616.           MOVE_LEFT (start);
  617.         }
  618.       MOVE_LEFT (start);
  619.       WIN_IF ((depth == 0) && sexp_flag);
  620.       break;
  621.  
  622.     case syntaxcode_endcomment:
  623.       if (! ignore_comments)
  624.         break;
  625.       while (true)
  626.         {
  627.           LOSE_IF_LEFT_END (start);
  628.           if ((SYNTAX_ENTRY_CODE (PEEK_LEFT (start))) ==
  629.           syntaxcode_comment)
  630.         break;
  631.           MOVE_LEFT (start);
  632.         }
  633.       break;
  634.  
  635.     default:
  636.       break;
  637.     }
  638.     }
  639. }
  640.  
  641. /* Partial S-Expression Parser */
  642.  
  643. #define LEVEL_ARRAY_LENGTH 100
  644. struct levelstruct { unsigned char * last, * previous; };
  645.  
  646. #define DONE_IF(expression) do                        \
  647. {                                    \
  648.   if (expression)                            \
  649.     goto done;                                \
  650. } while (0)
  651.  
  652. #define DONE_IF_RIGHT_END(scan) DONE_IF (RIGHT_END_P (scan))
  653.  
  654. #define SEXP_START() do                            \
  655. {                                    \
  656.   if (stop_before) goto stop;                        \
  657.   (level -> last) = start;                        \
  658. } while (0)
  659.  
  660. DEFINE_PRIMITIVE ("SCAN-SEXPS-FORWARD", Prim_scan_sexps_forward, 7, 7, 0)
  661. {
  662.   long target_depth;
  663.   Boolean stop_before;
  664.   SCHEME_OBJECT state_argument;
  665.   long depth;
  666.   long in_string;        /* -1 or delimiter character */
  667.   long in_comment;        /* 0, 1, or 2 */
  668.   Boolean quoted;
  669.   struct levelstruct level_start[LEVEL_ARRAY_LENGTH];
  670.   struct levelstruct *level;
  671.   struct levelstruct *level_end;
  672.   int c;
  673.   SCHEME_OBJECT result;
  674.   NORMAL_INITIALIZATION_FORWARD (7);
  675.  
  676.   target_depth = (arg_integer (5));
  677.   stop_before = (BOOLEAN_ARG (6));
  678.   state_argument = (ARG_REF (7));
  679.  
  680.   level = level_start;
  681.   level_end = (level_start + LEVEL_ARRAY_LENGTH);
  682.   (level -> previous) = NULL;
  683.  
  684.   /* Initialize the state variables from the state argument. */
  685.  
  686.   if (state_argument == SHARP_F)
  687.     {
  688.       depth = 0;
  689.       in_string = -1;
  690.       in_comment = 0;
  691.       quoted = false;
  692.     }
  693.   else if ((VECTOR_P (state_argument)) &&
  694.        (VECTOR_LENGTH (state_argument)) == 7)
  695.     {
  696.       SCHEME_OBJECT temp;
  697.  
  698.       temp = (VECTOR_REF (state_argument, 0));
  699.       if (FIXNUM_P (temp))
  700.     depth = (FIXNUM_TO_LONG (temp));
  701.       else
  702.     error_bad_range_arg (7);
  703.  
  704.       temp = (VECTOR_REF (state_argument, 1));
  705.       if (temp == SHARP_F)
  706.     in_string = -1;
  707.       else if ((UNSIGNED_FIXNUM_P (temp)) &&
  708.            ((UNSIGNED_FIXNUM_TO_LONG (temp)) < MAX_ASCII))
  709.     in_string = (UNSIGNED_FIXNUM_TO_LONG (temp));
  710.       else
  711.     error_bad_range_arg (7);
  712.  
  713.       temp = (VECTOR_REF (state_argument, 2));
  714.       if (temp == SHARP_F)
  715.     in_comment = 0;
  716.       else if (temp == (LONG_TO_UNSIGNED_FIXNUM (1)))
  717.     in_comment = 1;
  718.       else if (temp == (LONG_TO_UNSIGNED_FIXNUM (2)))
  719.     in_comment = 2;
  720.       else
  721.     error_bad_range_arg (7);
  722.  
  723.       quoted = ((VECTOR_REF (state_argument, 3)) != SHARP_F);
  724.  
  725.       if ((in_comment != 0) && ((in_string != -1) || (quoted != false)))
  726.     error_bad_range_arg (7);
  727.  
  728.     }
  729.   else
  730.     error_bad_range_arg (7);
  731.  
  732.   /* Make sure there is enough room for the result before we start. */
  733.  
  734.   Primitive_GC_If_Needed (8);
  735.  
  736.   /* Enter main loop at place appropiate for initial state. */
  737.  
  738.   if (in_comment == 1)
  739.     goto start_in_comment;
  740.   if (in_comment == 2)
  741.     goto start_in_comment2;
  742.   if (quoted)
  743.     {
  744.       quoted = false;
  745.       if (in_string != -1)
  746.     goto start_quoted_in_string;
  747.       else
  748.     goto start_quoted;
  749.     }
  750.   if (in_string != -1)
  751.     goto start_in_string;
  752.  
  753.   while (true)
  754.     {
  755.       DONE_IF_RIGHT_END (start);
  756.       c = (*start);
  757.       READ_RIGHT (start, sentry);
  758.       if ((! (RIGHT_END_P (start))) &&
  759.       (SYNTAX_ENTRY_COMSTART_FIRST (sentry)) &&
  760.       (SYNTAX_ENTRY_COMSTART_SECOND (PEEK_RIGHT (start))))
  761.     {
  762.       MOVE_RIGHT (start);
  763.       in_comment = 2;
  764.     start_in_comment2:
  765.       while (true)
  766.         {
  767.           DONE_IF_RIGHT_END (start);
  768.           READ_RIGHT (start, sentry);
  769.           if (SYNTAX_ENTRY_COMEND_FIRST (sentry))
  770.         {
  771.           /* Actually, terminating here is a special case.  There
  772.              should be a third value of in_comment to handle it. */
  773.           DONE_IF_RIGHT_END (start);
  774.           if (SYNTAX_ENTRY_COMEND_SECOND (PEEK_RIGHT (start)))
  775.             {
  776.               MOVE_RIGHT (start);
  777.               break;
  778.             }
  779.         }
  780.         }
  781.       in_comment = 0;
  782.     }
  783.       else if (SYNTAX_ENTRY_PREFIX (sentry))
  784.     continue;
  785.       else
  786.  
  787.     switch (SYNTAX_ENTRY_CODE (sentry))
  788.       {
  789.       case syntaxcode_escape:
  790.       case syntaxcode_charquote:
  791.         SEXP_START ();
  792.       start_quoted:
  793.         if (RIGHT_END_P (start))
  794.           {
  795.         quoted = true;
  796.         DONE_IF (true);
  797.           }
  798.         MOVE_RIGHT (start);
  799.         goto start_atom;
  800.  
  801.       case syntaxcode_word:
  802.       case syntaxcode_symbol:
  803.         SEXP_START ();
  804.       start_atom:
  805.         while (! (RIGHT_END_P (start)))
  806.           {
  807.         switch (SYNTAX_ENTRY_CODE (PEEK_RIGHT (start)))
  808.           {
  809.           case syntaxcode_escape:
  810.           case syntaxcode_charquote:
  811.             MOVE_RIGHT (start);
  812.             if (RIGHT_END_P (start))
  813.               {
  814.             quoted = true;
  815.             DONE_IF (true);
  816.               }
  817.  
  818.           case syntaxcode_word:
  819.           case syntaxcode_symbol:
  820.             MOVE_RIGHT (start);
  821.             break;
  822.  
  823.           default:
  824.             goto end_atom;
  825.           }
  826.           }
  827.       end_atom:
  828.         (level -> previous) = (level -> last);
  829.         break;
  830.  
  831.       case syntaxcode_comment:
  832.         in_comment = 1;
  833.       start_in_comment:
  834.         while (true)
  835.           {
  836.         DONE_IF_RIGHT_END (start);
  837.         READ_RIGHT (start, sentry);
  838.         if ((SYNTAX_ENTRY_CODE (sentry)) == syntaxcode_endcomment)
  839.           break;
  840.           }
  841.         in_comment = 0;
  842.         break;
  843.  
  844.       case syntaxcode_open:
  845.         SEXP_START ();
  846.         depth += 1;
  847.         level += 1;
  848.         if (level == level_end)
  849.           error_bad_range_arg (5); /* random error */
  850.         (level -> last) = NULL;
  851.         (level -> previous) = NULL;
  852.         DONE_IF ((--target_depth) == 0);
  853.         break;
  854.  
  855.       case syntaxcode_close:
  856.         depth -= 1;
  857.         if (level != level_start)
  858.           level -= 1;
  859.         (level -> previous) = (level -> last);
  860.         DONE_IF ((++target_depth) == 0);
  861.         break;
  862.  
  863.       case syntaxcode_string:
  864.         SEXP_START ();
  865.         in_string = (c);
  866.       start_in_string:
  867.         while (true)
  868.           {
  869.         DONE_IF_RIGHT_END (start);
  870.         if (in_string == (*start))
  871.           break;
  872.         READ_RIGHT (start, sentry);
  873.         if (SYNTAX_ENTRY_QUOTE (sentry))
  874.           {
  875.           start_quoted_in_string:
  876.             if (RIGHT_END_P (start))
  877.               {
  878.             quoted = true;
  879.             DONE_IF (true);
  880.               }
  881.             MOVE_RIGHT (start);
  882.           }
  883.           }
  884.         in_string = -1;
  885.         (level -> previous) = (level -> last);
  886.         MOVE_RIGHT (start);
  887.         break;
  888.       }
  889.     }
  890.   /* NOTREACHED */
  891.  
  892.  stop:
  893.   /* Back up to point at character that starts sexp. */
  894.   if (start == gap_end)
  895.     start = gap_start;
  896.   start -= 1;
  897.  
  898.  done:
  899.   result = (allocate_marked_vector (TC_VECTOR, 7, true));
  900.   FAST_VECTOR_SET (result, 0, (LONG_TO_FIXNUM (depth)));
  901.   FAST_VECTOR_SET
  902.     (result, 1,
  903.      ((in_string == -1)
  904.       ? SHARP_F
  905.       : (LONG_TO_UNSIGNED_FIXNUM (in_string))));
  906.   FAST_VECTOR_SET
  907.     (result, 2,
  908.      ((in_comment == 0)
  909.       ? SHARP_F
  910.       : (LONG_TO_UNSIGNED_FIXNUM (in_comment))));
  911.   FAST_VECTOR_SET (result, 3, (BOOLEAN_TO_OBJECT (quoted)));
  912.   FAST_VECTOR_SET
  913.     (result, 4,
  914.      (((level -> previous) == NULL)
  915.       ? SHARP_F
  916.       : (LONG_TO_UNSIGNED_FIXNUM ((SCAN_TO_INDEX (level -> previous)) - 1))));
  917.   FAST_VECTOR_SET
  918.     (result, 5,
  919.      (((level == level_start) || (((level - 1) -> last) == NULL))
  920.       ? SHARP_F
  921.       : (LONG_TO_UNSIGNED_FIXNUM
  922.      ((SCAN_TO_INDEX ((level - 1) -> last)) - 1))));
  923.   FAST_VECTOR_SET
  924.     (result, 6, (LONG_TO_UNSIGNED_FIXNUM (SCAN_TO_INDEX (start))));
  925.   PRIMITIVE_RETURN (result);
  926. }
  927.